home *** CD-ROM | disk | FTP | other *** search
- {
- $Id: pexpr.pas,v 1.2.2.1 1998/05/21 12:26:55 carl Exp $
- Copyright (c) 1998 by Florian Klaempfl
-
- Does parsing of expression for Free Pascal
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
- ****************************************************************************
- }
- unit pexpr;
-
- interface
-
- uses symtable,tree;
-
- { reads a whole expression }
- function expr : ptree;
-
- { reads a single factor }
- function factor(getaddr : boolean) : ptree;
-
- { the ID token has to be consumed before calling this function }
- procedure do_member_read(const sym : psym;var p1 : ptree;
- var pd : pdef;var again : boolean);
-
- function get_intconst:longint;
-
- function get_stringconst:string;
-
- implementation
-
- uses
- cobjects,globals,scanner,aasm,pass_1,systems,
- hcodegen,types,verbose
- { parser specific stuff }
- ,pbase,pdecl
- { processor specific stuff }
- {$ifdef i386}
- ,i386
- {$endif}
- {$ifdef m68k}
- ,m68k
- {$endif}
- ;
-
- function parse_paras(_colon,in_prop_paras : boolean) : ptree;
-
- var
- p1,p2 : ptree;
- end_of_paras : ttoken;
-
- begin
- if in_prop_paras then
- end_of_paras:=RECKKLAMMER
- else
- end_of_paras:=RKLAMMER;
- if token=end_of_paras then
- begin
- parse_paras:=nil;
- exit;
- end;
- p2:=nil;
- inc(parsing_para_level);
- while true do
- begin
- p1:=expr;
- p2:=gencallparanode(p1,p2);
-
- { it's for the str(l:5,s); }
- if _colon and (token=COLON) then
- begin
- consume(COLON);
- p1:=expr;
- p2:=gencallparanode(p1,p2);
- p2^.is_colon_para:=true;
- if token=COLON then
- begin
- consume(COLON);
- p1:=expr;
- p2:=gencallparanode(p1,p2);
- p2^.is_colon_para:=true;
- end
- end;
- if token=COMMA then
- consume(COMMA)
- else
- break;
- end;
- dec(parsing_para_level);
- parse_paras:=p2;
- end;
-
- function statement_syssym(l : longint;var pd : pdef) : ptree;
- { const regnames:array[R_EAX..R_EDI] of string[3]=
- ('EAX','ECX','EDX','EBX','','','ESI','EDI'); }
-
- var
- p1,p2 : ptree;
- paras : ptree;
- prev_in_args : boolean;
- Store_valid : boolean;
-
- begin
- prev_in_args:=in_args;
- Store_valid:=Must_be_valid;
- case l of
- in_ord_x :
- begin
- consume(LKLAMMER);
- in_args:=true;
- Must_be_valid:=true;
- p1:=expr;
- consume(RKLAMMER);
- do_firstpass(p1);
- p1:=geninlinenode(in_ord_x,p1);
- do_firstpass(p1);
- statement_syssym := p1;
- pd:=p1^.resulttype;
- end;
- in_typeof_x : begin
- consume(LKLAMMER);
- in_args:=true;
- p1:=expr;
- consume(RKLAMMER);
- pd:=voidpointerdef;
- if p1^.treetype=typen then
- begin
- if (p1^.resulttype=nil) then
- begin
- Message(sym_e_type_mismatch);
- statement_syssym:=genzeronode(errorn);
- end
- else
- if p1^.resulttype^.deftype=objectdef then
- statement_syssym:=geninlinenode(in_typeof_x,p1)
- else
- begin
- Message(sym_e_type_mismatch);
- statement_syssym:=genzeronode(errorn);
- end;
- end
- else
- begin
- Must_be_valid:=false;
- do_firstpass(p1);
- if (p1^.resulttype=nil) then
- begin
- Message(sym_e_type_mismatch);
- statement_syssym:=genzeronode(errorn)
- end
- else
- if p1^.resulttype^.deftype=objectdef then
- statement_syssym:=geninlinenode(in_typeof_x,p1)
- else
- begin
- Message(sym_e_type_mismatch);
- statement_syssym:=genzeronode(errorn)
- end;
- end;
- end;
- in_sizeof_x : begin
- consume(LKLAMMER);
- in_args:=true;
- p1:=expr;
- consume(RKLAMMER);
- pd:=s32bitdef;
- if p1^.treetype=typen then
- begin
- statement_syssym:=genordinalconstnode(
- p1^.resulttype^.size,pd);
- { p1 not needed !}
- disposetree(p1);
- end
- else
- begin
- Must_be_valid:=false;
- do_firstpass(p1);
- if p1^.resulttype^.deftype<>objectdef then
- begin
- statement_syssym:=genordinalconstnode(
- p1^.resulttype^.size,pd);
- { p1 not needed !}
- disposetree(p1);
- end
- else
- begin
- statement_syssym:=geninlinenode(in_sizeof_x,p1);
- end;
- end;
- end;
- in_assigned_x : begin
- consume(LKLAMMER);
- in_args:=true;
- p1:=expr;
- Must_be_valid:=true;
- do_firstpass(p1);
- case p1^.resulttype^.deftype of
- pointerdef,procvardef,
- classrefdef:
- ;
- objectdef:
- if not(pobjectdef(p1^.resulttype)^.isclass) then
- Message(parser_e_illegal_parameter_list);
- else Message(parser_e_illegal_parameter_list);
- end;
- p2:=gencallparanode(p1,nil);
- p2:=geninlinenode(in_assigned_x,p2);
- consume(RKLAMMER);
- pd:=booldef;
- statement_syssym:=p2;
- end;
- in_ofs_x : begin
- consume(LKLAMMER);
- in_args:=true;
- p1:=expr;
- p1:=gensinglenode(addrn,p1);
- Must_be_valid:=false;
- do_firstpass(p1);
- { Ofs() returns a longint, not a pointer }
- p1^.resulttype:=u32bitdef;
- pd:=p1^.resulttype;
- consume(RKLAMMER);
- statement_syssym:=p1;
- end;
- in_seg_x : begin
- consume(LKLAMMER);
- in_args:=true;
- p1:=expr;
- do_firstpass(p1);
- if p1^.location.loc<>LOC_REFERENCE then
- Message(cg_e_illegal_expression);
- p1:=genordinalconstnode(0,s32bitdef);
- Must_be_valid:=false;
- pd:=s32bitdef;
- consume(RKLAMMER);
- statement_syssym:=p1;
- end;
- in_high_x,
- in_low_x : begin
- consume(LKLAMMER);
- in_args:=true;
- p1:=expr;
- do_firstpass(p1);
- Must_be_valid:=false;
- p2:=geninlinenode(l,p1);
- consume(RKLAMMER);
- pd:=s32bitdef;
- statement_syssym:=p2;
- end;
- in_succ_x,
- in_pred_x : begin
- consume(LKLAMMER);
- in_args:=true;
- p1:=expr;
- do_firstpass(p1);
- Must_be_valid:=false;
- p2:=geninlinenode(l,p1);
- consume(RKLAMMER);
- pd:=p1^.resulttype;
- statement_syssym:=p2;
- end;
- in_inc_x,
- in_dec_x : begin
- consume(LKLAMMER);
- in_args:=true;
- p1:=expr;
- p2:=gencallparanode(p1,nil);
- Must_be_valid:=false;
- if token=COMMA then
- begin
- consume(COMMA);
- p1:=expr;
- p2:=gencallparanode(p1,p2);
- end;
- statement_syssym:=geninlinenode(l,p2);
- consume(RKLAMMER);
- pd:=voiddef;
- end;
- in_concat_x : begin
- consume(LKLAMMER);
- in_args:=true;
- p2:=nil;
- while true do
- begin
- p1:=expr;
- Must_be_valid:=true;
- do_firstpass(p1);
- if not((p1^.resulttype^.deftype=stringdef) or
- ((p1^.resulttype^.deftype=orddef) and
- (porddef(p1^.resulttype)^.typ=uchar)
- )
- ) then Message(parser_e_illegal_parameter_list);
- if p2<>nil then
- p2:=gennode(addn,p2,p1)
- else p2:=p1;
- if token=COMMA then
- consume(COMMA)
- else break;
- end;
- consume(RKLAMMER);
- pd:=cstringdef;
- statement_syssym:=p2;
- end;
- in_read_x,
- in_readln_x : begin
- if token=LKLAMMER then
- begin
- consume(LKLAMMER);
- in_args:=true;
- Must_be_valid:=false;
- paras:=parse_paras(false,false);
- consume(RKLAMMER);
- end
- else
- paras:=nil;
- pd:=voiddef;
- p1:=geninlinenode(l,paras);
- do_firstpass(p1);
- statement_syssym := p1;
- end;
- in_write_x,
- in_writeln_x : begin
- if token=LKLAMMER then
- begin
- consume(LKLAMMER);
- in_args:=true;
- Must_be_valid:=true;
- paras:=parse_paras(true,false);
- consume(RKLAMMER);
- end
- else
- paras:=nil;
- pd:=voiddef;
- p1 := geninlinenode(l,paras);
- do_firstpass(p1);
- statement_syssym := p1;
- end;
- in_str_x_string : begin
- consume(LKLAMMER);
- in_args:=true;
- paras:=parse_paras(true,false);
- consume(RKLAMMER);
- p1 := geninlinenode(l,paras);
- do_firstpass(p1);
- statement_syssym := p1;
- pd:=voiddef;
- end;
- {in_val_x : begin
- consume(LKLAMMER);
- paras:=parse_paras(false);
- consume(RKLAMMER);
- p1 := geninlinenode(l,paras);
- do_firstpass(p1);
- statement_syssym := p1;
- pd:=voiddef;
- end; }
- else internalerror(15);
- end;
- in_args:=prev_in_args;
- Must_be_valid:=Store_valid;
- end;
-
- { reads the parameter for a subroutine call }
- procedure do_proc_call(getaddr : boolean;var again : boolean;var p1:Ptree;var pd:Pdef);
-
- var
- prev_in_args : boolean;
- prevafterassn : boolean;
-
- begin
- prev_in_args:=in_args;
- prevafterassn:=afterassignment;
- afterassignment:=false;
- { want we only determine the address of }
- { a subroutine }
- if not(getaddr) then
- begin
- if token=LKLAMMER then
- begin
- consume(LKLAMMER);
- in_args:=true;
- p1^.left:=parse_paras(false,false);
- consume(RKLAMMER);
- end
- else p1^.left:=nil;
-
- { do firstpass because we need the }
- { result type }
- do_firstpass(p1);
- end
- else
- begin
- { address operator @: }
- p1^.left:=nil;
- { forget pd }
- pd:=nil;
- { no postfix operators }
- again:=false;
- end;
- pd:=p1^.resulttype;
- in_args:=prev_in_args;
- afterassignment:=prevafterassn;
- end;
-
- { the ID token has to be consumed before calling this function }
- procedure do_member_read(const sym : psym;var p1 : ptree;
- var pd : pdef;var again : boolean);
-
- var
- static_name : string;
- paras : ptree;
- oldafterassignment,isclassref : boolean;
- p2 : ptree;
-
- begin
- if sym=nil then
- begin
- Message(sym_e_id_no_member);
- disposetree(p1);
- p1:=genzeronode(errorn);
- { try to clean up }
- pd:=generrordef;
- again:=false;
- end
- else
- begin
- isclassref:=pd^.deftype=classrefdef;
- { we assume, that only procsyms and varsyms are in an object }
- { symbol table, for classes, properties are allowed }
- case sym^.typ of
- procsym:
- begin
- p1:=genmethodcallnode(pprocsym(sym),srsymtable,p1);
- do_proc_call(false,again,p1,pd);
- { now we know the real method e.g. we can check for }
- { a class method }
- if isclassref and ((p1^.procdefinition^.options and (poclassmethod or poconstructor))=0) then
- Message(parser_e_only_class_methods_via_class_ref);
- end;
- varsym:
- begin
- if isclassref then
- Message(parser_e_only_class_methods_via_class_ref);
- if (sym^.properties and sp_static)<>0 then
- begin
- static_name:=lowercase(srsymtable^.name^)+'_'+sym^.name;
- getsym(static_name,true);
- disposetree(p1);
- p1:=genloadnode(pvarsym(srsym),srsymtable);
- end
- else
- p1:=gensubscriptnode(pvarsym(sym),p1);
- pd:=pvarsym(sym)^.definition;
- end;
- propertysym:
- begin
- if isclassref then
- Message(parser_e_only_class_methods_via_class_ref);
- paras:=nil;
- { property parameters? }
- if token=LECKKLAMMER then
- begin
- consume(LECKKLAMMER);
- paras:=parse_paras(false,true);
- consume(RECKKLAMMER);
- end;
- { indexed property }
- if (ppropertysym(sym)^.options and ppo_indexed)<>0 then
- begin
- p2:=genordinalconstnode(ppropertysym(sym)^.index,s32bitdef);
- paras:=gencallparanode(p2,paras);
- end;
- if not(afterassignment) and not(in_args) then
- begin
- { write property: }
- { no result }
- pd:=voiddef;
- if assigned(ppropertysym(sym)^.writeaccesssym) then
- begin
- if ppropertysym(sym)^.writeaccesssym^.typ=procsym then
- begin
- { generate the method call }
- p1:=genmethodcallnode(pprocsym(
- ppropertysym(sym)^.writeaccesssym),
- ppropertysym(sym)^.writeaccesssym^.owner,p1);
- p1^.left:=paras;
- { to be on the save side }
- oldafterassignment:=afterassignment;
- consume(ASSIGNMENT);
- { read the expression }
- afterassignment:=true;
- p2:=expr;
- p1^.left:=gencallparanode(p2,p1^.left);
- afterassignment:=oldafterassignment;
- end
- else if ppropertysym(sym)^.writeaccesssym^.typ=varsym then
- begin
- if assigned(paras) then
- message(parser_e_no_paras_allowed);
- p1:=gensubscriptnode(pvarsym(
- ppropertysym(sym)^.readaccesssym),p1);
- { to be on the save side }
- oldafterassignment:=afterassignment;
- consume(ASSIGNMENT);
- { read the expression }
- afterassignment:=true;
- p2:=expr;
- p1:=gennode(assignn,p1,p2);
- afterassignment:=oldafterassignment;
- end
- else
- begin
- p1:=genzeronode(errorn);
- Message(parser_e_no_procedure_to_access_property);
- end;
- end
- else
- begin
- p1:=genzeronode(errorn);
- Message(parser_e_no_procedure_to_access_property);
- end;
- end
- else
- begin
- { read property: }
- pd:=ppropertysym(sym)^.proptype;
- if assigned(ppropertysym(sym)^.readaccesssym) then
- begin
- if ppropertysym(sym)^.readaccesssym^.typ=varsym then
- begin
- if assigned(paras) then
- message(parser_e_no_paras_allowed);
- p1:=gensubscriptnode(pvarsym(
- ppropertysym(sym)^.readaccesssym),p1);
- pd:=pvarsym(sym)^.definition;
- end
- else if ppropertysym(sym)^.readaccesssym^.typ=procsym then
- begin
- { generate the method call }
- p1:=genmethodcallnode(pprocsym(
- ppropertysym(sym)^.readaccesssym),
- ppropertysym(sym)^.readaccesssym^.owner,p1);
- { insert paras }
- p1^.left:=paras;
- { if we should be delphi compatible }
- { then force type conversion }
- if cs_delphi2_compatible in aktswitches then
- p1:=gentypeconvnode(p1,pd);
- end
- else
- begin
- p1:=genzeronode(errorn);
- Message(sym_e_type_mismatch);
- end;
- end
- else
- begin
- { error, no function to read property }
- p1:=genzeronode(errorn);
- Message(parser_e_no_procedure_to_access_property);
- end;
- end;
- end;
- else internalerror(16);
- end;
- end;
- end;
-
- function factor(getaddr : boolean) : ptree;
-
- var
- l : longint;
- p1,p2,p3 : ptree;
- code : word;
- pd,pd2 : pdef;
- unit_specific, again : boolean;
- static_name : string;
- sym : pvarsym;
- classh : pobjectdef;
- d : bestreal;
- constset : pconstset;
-
-
- { p1 and p2 must contain valid values }
- procedure postfixoperators;
-
- begin
- while again do
- begin
- case token of
- CARET:
- begin
- consume(CARET);
- if pd^.deftype<>pointerdef then
- begin
- { ^ as binary operator is a problem!!!! (FK) }
- again:=false;
- Message(cg_e_invalid_qualifier);
- disposetree(p1);
- p1:=genzeronode(errorn);
- end
- else
- begin
- p1:=gensinglenode(derefn,p1);
- pd:=ppointerdef(pd)^.definition;
- end;
- end;
- LECKKLAMMER : begin
- consume(LECKKLAMMER);
- repeat
- if (pd^.deftype<>arraydef) and
- (pd^.deftype<>stringdef) and
- (pd^.deftype<>pointerdef) then
- begin
- Message(cg_e_invalid_qualifier);
- disposetree(p1);
- p1:=genzeronode(errorn);
- end
- else if (pd^.deftype=pointerdef) then
- begin
- p2:=expr;
- p1:=gennode(vecn,p1,p2);
- pd:=ppointerdef(pd)^.definition;
- end
- else
- begin
- p2:=expr;
- { support SEG:OFS for go32v2 Mem[] }
- if (target_info.target=target_GO32V2) and
- assigned(p1^.symtableentry) and
- assigned(p1^.symtableentry^.owner^.name) and
- (p1^.symtableentry^.owner^.name^='SYSTEM') and
- ((p1^.symtableentry^.name='MEM') or
- (p1^.symtableentry^.name='MEMW') or
- (p1^.symtableentry^.name='MEML')) then
- begin
- if (token=COLON) then
- begin
- consume(COLON);
- p3:=gennode(muln,genordinalconstnode($10,s32bitdef),p2);
- p2:=expr;
- p2:=gennode(addn,p2,p3);
- p1:=gennode(vecn,p1,p2);
- p1^.memseg:=true;
- p1^.memindex:=true;
- end
- else
- begin
- p1:=gennode(vecn,p1,p2);
- p1^.memindex:=true;
- end;
- end
- else
- p1:=gennode(vecn,p1,p2);
- if pd^.deftype=stringdef then
- pd:=cchardef
- else
- pd:=parraydef(pd)^.definition;
- end;
- if token=COMMA then consume(COMMA)
- else break;
- until false;
- consume(RECKKLAMMER);
- end;
- POINT : begin
- consume(POINT);
- case pd^.deftype of
- recorddef:
- begin
- sym:=pvarsym(precdef(pd)^.symtable^.search(pattern));
- consume(ID);
- if sym=nil then
- begin
- Message(sym_e_illegal_field);
- disposetree(p1);
- p1:=genzeronode(errorn);
- end
- else
- begin
- p1:=gensubscriptnode(sym,p1);
- pd:=sym^.definition;
- end;
- end;
- classrefdef:
- begin
- classh:=pobjectdef(pclassrefdef(pd)^.definition);
- sym:=nil;
- while assigned(classh) do
- begin
- sym:=pvarsym(classh^.publicsyms^.search(pattern));
- srsymtable:=classh^.publicsyms;
- if assigned(sym) then
- break;
- classh:=classh^.childof;
- end;
- consume(ID);
- do_member_read(sym,p1,pd,again);
- end;
- objectdef:
- begin
- classh:=pobjectdef(pd);
- sym:=nil;
- while assigned(classh) do
- begin
- sym:=pvarsym(classh^.publicsyms^.search(pattern));
- srsymtable:=classh^.publicsyms;
- if assigned(sym) then
- break;
- classh:=classh^.childof;
- end;
- consume(ID);
- do_member_read(sym,p1,pd,again);
- end;
- pointerdef:
- begin
- if ppointerdef(pd)^.definition^.deftype
- in [recorddef,objectdef,classrefdef] then
- begin
- Message(cg_e_invalid_qualifier);
- { exterror:=strpnew(' may be pointer deref ^ is missing');
- error(invalid_qualifizier); }
- Comment(V_hint,' may be pointer deref ^ is missing');
- end
- else
- Message(cg_e_invalid_qualifier);
- end
- else
- begin
- Message(cg_e_invalid_qualifier);
- disposetree(p1);
- p1:=genzeronode(errorn);
- end;
- end;
- end;
- else
- begin
- { is this a procedure variable ? }
- if assigned(pd) then
- begin
- if (pd^.deftype=procvardef) then
- begin
- if getprocvar then
- again:=false
- else
- if (token=LKLAMMER) or
- ((pprocvardef(pd)^.para1=nil) and
- (token<>ASSIGNMENT) and (not in_args)) then
- begin
- { do this in a strange way }
- { it's not a clean solution }
- p2:=p1;
- p1:=gencallnode(nil,
- nil);
- p1^.right:=p2;
- p1^.unit_specific:=unit_specific;
- if token=LKLAMMER then
- begin
- consume(LKLAMMER);
- p1^.left:=parse_paras(false,false);
- consume(RKLAMMER);
- end;
- pd:=pprocvardef(pd)^.retdef;
- p1^.resulttype:=pd;
- end
- else again:=false;
- p1^.resulttype:=pd;
- end
- else again:=false;
- end
- else again:=false;
- end;
- end;
- end;
- end;
-
- procedure do_set(p : pconstset;pos : longint);
-
- var
- l : longint;
-
- begin
- if (pos>255) or
- (pos<0) then
- Message(parser_e_illegal_set_expr);
- l:=pos div 8;
- { do we allow the same twice }
- if (p^[l] and (1 shl (pos mod 8)))<>0 then
- Message(parser_e_illegal_set_expr);
- p^[l]:=p^[l] or (1 shl (pos mod 8));
- end;
-
- var
- possible_error : boolean;
- storesymtablestack : psymtable;
- actprocsym : pprocsym;
-
- begin
- case token of
- ID:
- begin
- { allow post fix operators }
- again:=true;
- if (cs_delphi2_compatible in aktswitches) and
- (pattern='RESULT') and
- assigned(aktprocsym) and
- (procinfo.retdef<>pdef(voiddef)) then
- begin
- consume(ID);
- p1:=genzeronode(funcretn);
- pd:=procinfo.retdef;
- {$ifdef TEST_FUNCRET}
- p1^.funcretprocinfo:=pointer(@procinfo);
- p1^.retdef:=pd;
- {$endif TEST_FUNCRET}
- end
- else
- begin
- getsym(pattern,true);
- consume(ID);
- { is this an access to a function result ? }
- if assigned(aktprocsym) and
- ((srsym^.name=aktprocsym^.name) or
- ((pvarsym(srsym)=opsym) and
- ((pprocdef(aktprocsym^.definition)^.options and pooperator)<>0))) and
- (procinfo.retdef<>pdef(voiddef)) and
- (token<>LKLAMMER) and
- (not ((cs_tp_compatible in aktswitches) and
- (afterassignment or in_args))) then
- begin
- p1:=genzeronode(funcretn);
- pd:=procinfo.retdef;
- {$ifdef TEST_FUNCRET}
- p1^.funcretprocinfo:=pointer(@procinfo);
- p1^.retdef:=pd;
- {$endif TEST_FUNCRET}
- end
- else
- { else it's a normal symbol }
- begin
- if srsym^.typ=unitsym then
- begin
- consume(POINT);
- getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
- unit_specific:=true;
- consume(ID);
- end
- else
- unit_specific:=false;
-
- if not assigned(srsym) then
- Begin
- p1:=genzeronode(errorn);
- { try to clean up }
- pd:=generrordef;
- end
- else
- case srsym^.typ of
- absolutesym:
- begin
- p1:=genloadnode(pvarsym(srsym),srsymtable);
- pd:=pabsolutesym(srsym)^.definition;
- end;
- varsym:
- begin
- { are we in a class method ? }
- if (srsymtable^.symtabletype=objectsymtable) and
- assigned(aktprocsym) and
- ((aktprocsym^.definition^.options and poclassmethod)<>0) then
- Message(parser_e_only_class_methods);
-
- if (srsym^.properties and sp_static)<>0 then
- begin
- static_name:=lowercase(srsymtable^.name^)+'_'+srsym^.name;
- getsym(static_name,true);
- end;
- p1:=genloadnode(pvarsym(srsym),srsymtable);
- if pvarsym(srsym)^.is_valid=0 then
- begin
- p1^.is_first := true;
- { set special between first loaded
- until checked in firstpass }
- pvarsym(srsym)^.is_valid:=2;
- end;
- pd:=pvarsym(srsym)^.definition;
- end;
- typedconstsym:
- begin
- p1:=gentypedconstloadnode(ptypedconstsym(srsym),srsymtable);
- pd:=ptypedconstsym(srsym)^.definition;
- end;
- syssym:
- p1:=statement_syssym(psyssym(srsym)^.number,pd);
- typesym:
- begin
- pd:=ptypesym(srsym)^.definition;
- if token=LKLAMMER then
- begin
- consume(LKLAMMER);
- p1:=expr;
- consume(RKLAMMER);
- p1:=gentypeconvnode(p1,pd);
- p1^.explizit:=true;
- end
- else if (token=POINT) and
- (pd^.deftype=objectdef) and
- ((pobjectdef(pd)^.options and oois_class)=0) then
- begin
- consume(POINT);
- if assigned(procinfo._class) then
- begin
- if procinfo._class^.isrelated(pobjectdef(pd)) then
- begin
- p1:=genzeronode(typen);
- p1^.resulttype:=pd;
- srsymtable:=pobjectdef(pd)^.publicsyms;
- sym:=pvarsym(srsymtable^.search(pattern));
- consume(ID);
- do_member_read(sym,p1,pd,again);
- end
- else
- begin
- Message(parser_e_no_super_class);
- pd:=generrordef;
- again:=false;
- end;
- end
- else
- begin
- { allows @TObject.Load }
- { also allows static methods and variables }
-
- p1:=genzeronode(typen);
- p1^.resulttype:=pd;
- srsymtable:=pobjectdef(pd)^.publicsyms;
- sym:=pvarsym(srsymtable^.search(pattern));
- if not(getaddr) and
- ((sym^.properties and sp_static)=0) then
- Message(sym_e_only_static_in_static)
- else
- begin
- consume(ID);
- do_member_read(sym,p1,pd,again);
- end;
- end
- end
- else
- begin
- { class reference ? }
- if (pd^.deftype=objectdef)
- and ((pobjectdef(pd)^.options and oois_class)<>0) then
- begin
- p1:=genzeronode(typen);
- p1^.resulttype:=pd;
- pd:=new(pclassrefdef,init(pd));
- p1:=gensinglenode(loadvmtn,p1);
- p1^.resulttype:=pd;
- end
- else
- begin
- { generate a type node }
- { (for typeof etc) }
- p1:=genzeronode(typen);
- p1^.resulttype:=pd;
- pd:=voiddef;
- end;
- end;
- end;
- enumsym:
- begin
- p1:=genenumnode(penumsym(srsym));
- pd:=p1^.resulttype;
- end;
- constsym:
- begin
- case pconstsym(srsym)^.consttype of
- constint:
- p1:=genordinalconstnode(pconstsym(srsym)^.value,s32bitdef);
- conststring:
- p1:=genstringconstnode(pstring(pconstsym(srsym)^.value)^);
- constchar:
- p1:=genordinalconstnode(pconstsym(srsym)^.value,cchardef);
- constreal:
- p1:=genrealconstnode(pdouble(pconstsym(srsym)^.value)^);
- constbool:
- p1:=genordinalconstnode(pconstsym(srsym)^.value,booldef);
- constseta:
- p1:=gensetconstruktnode(pconstset(pconstsym(srsym)^.value),
- psetdef(pconstsym(srsym)^.definition));
- constord:
- p1:=genordinalconstnode(pconstsym(srsym)^.value,
- pconstsym(srsym)^.definition);
- end;
- pd:=p1^.resulttype;
- end;
- procsym:
- begin
- { are we in a class method ? }
- possible_error:=(srsymtable^.symtabletype=objectsymtable) and
- assigned(aktprocsym) and
- ((aktprocsym^.definition^.options and poclassmethod)<>0);
- p1:=gencallnode(pprocsym(srsym),srsymtable);
- p1^.unit_specific:=unit_specific;
- do_proc_call(getaddr,again,p1,pd);
- if possible_error and
- ((p1^.procdefinition^.options and poclassmethod)=0) then
- Message(parser_e_only_class_methods);
- end;
- propertysym:
- begin
- { access to property in a method }
-
- { are we in a class method ? }
- if (srsymtable^.symtabletype=objectsymtable) and
- assigned(aktprocsym) and
- ((aktprocsym^.definition^.options and poclassmethod)<>0) then
- Message(parser_e_only_class_methods);
- { !!!!! }
- end;
- errorsym:
- begin
- p1:=genzeronode(errorn);
- pd:=generrordef;
- if token=LKLAMMER then
- begin
- consume(LKLAMMER);
- parse_paras(false,false);
- consume(RKLAMMER);
- end;
- end;
- else
- begin
- p1:=genzeronode(errorn);
- pd:=generrordef;
- Message(cg_e_illegal_expression);
- end;
- end; { end case }
- end;
- end;
- { handle post fix operators }
- postfixoperators;
- end;
- _NEW : begin
- consume(_NEW);
- consume(LKLAMMER);
- p1:=factor(false);
- if p1^.treetype<>typen then
- Message(sym_e_type_id_expected);
- pd:=p1^.resulttype;
- pd2:=pd;
- if (pd^.deftype<>pointerdef) or
- (ppointerdef(pd)^.definition^.deftype<>objectdef) then
- begin
- Message(parser_e_pointer_to_class_expected);
-
- { if an error occurs, read til the end of the new }
- { statement }
- p1:=genzeronode(errorn);
- l:=1;
- while true do
- begin
- case token of
- LKLAMMER : inc(l);
- RKLAMMER : dec(l);
- end;
- consume(token);
- if l=0 then
- break;
- end;
- end
- else
- begin
- disposetree(p1);
- p1:=genzeronode(hnewn);
- p1^.resulttype:=ppointerdef(pd)^.definition;
- consume(COMMA);
-
- afterassignment:=false;
- { determines the current object defintion }
- classh:=pobjectdef(ppointerdef(pd)^.definition);
-
- { check for an abstract class }
- if (classh^.options and oois_abstract)<>0 then
- Message(sym_e_no_instance_of_abstract_object);
-
- { search the constructor also in the symbol tables of }
- { the parents }
-
- { no constructor found }
- sym:=nil;
- while assigned(classh) do
- begin
- sym:=pvarsym(classh^.publicsyms^.search(pattern));
- srsymtable:=classh^.publicsyms;
- if assigned(sym) then
- break;
- classh:=classh^.childof;
- end;
-
- consume(ID);
- do_member_read(sym,p1,pd,again);
- if (p1^.treetype<>calln) or
- (assigned(p1^.procdefinition) and
- ((p1^.procdefinition^.options and poconstructor)=0)) then
- Message(parser_e_expr_have_to_be_constructor_call);
- p1:=gensinglenode(newn,p1);
-
- { set the resulttype }
- p1^.resulttype:=pd2;
- consume(RKLAMMER);
- end;
- end;
- _SELF:
- begin
- again:=true;
- consume(_SELF);
- if not assigned(procinfo._class) then
- begin
- p1:=genzeronode(errorn);
- pd:=generrordef;
- again:=false;
- Message(parser_e_self_not_in_method);
- end
- else
- begin
- if (aktprocsym^.definition^.options and poclassmethod)<>0 then
- begin
- { self in class methods is a class reference type }
- pd:=new(pclassrefdef,init(procinfo._class));
- p1:=genselfnode(pd);
- p1^.resulttype:=pd;
- end
- else
- begin
- p1:=genselfnode(procinfo._class);
- p1^.resulttype:=procinfo._class;
- end;
- pd:=p1^.resulttype;
- postfixoperators;
- end;
- end;
- _INHERITED : begin
- again:=true;
- consume(_INHERITED);
- if assigned(procinfo._class) then
- begin
- classh:=procinfo._class^.childof;
- while assigned(classh) do
- begin
- srsymtable:=pobjectdef(classh)^.publicsyms;
- sym:=pvarsym(srsymtable^.search(pattern));
- if assigned(sym) then
- begin
- p1:=genzeronode(typen);
- p1^.resulttype:=classh;
- pd:=p1^.resulttype;
- consume(ID);
- do_member_read(sym,p1,pd,again);
- break;
- end;
- classh:=classh^.childof;
- end;
- if classh=nil then
- begin
- Message1(sym_e_id_no_member,pattern);
- again:=false;
- pd:=generrordef;
- p1:=genzeronode(errorn);
- end;
- end
- else
- Message(parser_e_generic_methods_only_in_methods);
- postfixoperators;
- end;
- INTCONST : begin
- valint(pattern,l,code);
- if code<>0 then
- begin
- val(pattern,d,code);
- if code<>0 then
- begin
- Message(cg_e_invalid_integer);
- l:=1;
- consume(INTCONST);
- p1:=genordinalconstnode(l,s32bitdef);
- end
- else
- begin
- consume(INTCONST);
- p1:=genrealconstnode(d);
- end;
- end
- else
- begin
- consume(INTCONST);
- p1:=genordinalconstnode(l,s32bitdef);
- end;
- end;
- REALNUMBER : begin
- val(pattern,d,code);
- if code<>0 then
- begin
- Message(parser_e_error_in_real);
- d:=1.0;
- end;
- consume(REALNUMBER);
- p1:=genrealconstnode(d);
- end;
- { FILE and STRING can be also a type cast }
- _STRING:
- begin
- pd:=stringtype;
- consume(LKLAMMER);
- p1:=expr;
- consume(RKLAMMER);
- p1:=gentypeconvnode(p1,pd);
- p1^.explizit:=true;
- { handle postfix operators here e.g. string(a)[10] }
- again:=true;
- postfixoperators;
- end;
- _FILE:
- begin
- pd:=cfiledef;
- consume(_FILE);
- consume(LKLAMMER);
- p1:=expr;
- consume(RKLAMMER);
- p1:=gentypeconvnode(p1,pd);
- p1^.explizit:=true;
- { handle postfix operators here e.g. string(a)[10] }
- again:=true;
- postfixoperators;
- end;
- CSTRING:
- begin
- p1:=genstringconstnode(pattern);
- consume(CSTRING);
- end;
- CCHAR:
- begin
- p1:=genordinalconstnode(ord(pattern[1]),cchardef);
- consume(CCHAR);
- end;
- KLAMMERAFFE : begin
- consume(KLAMMERAFFE);
- p1:=factor(true);
- p1:=gensinglenode(addrn,p1);
- end;
- LKLAMMER : begin
- consume(LKLAMMER);
- p1:=expr;
- consume(RKLAMMER);
- { it's not a good solution }
- { but (a+b)^ makes some problems }
- case token of
- CARET,POINT,LECKKLAMMER:
- begin
- { we need the resulttype }
- { of the expression in pd }
- do_firstpass(p1);
- pd:=p1^.resulttype;
-
- again:=true;
- postfixoperators;
- end;
- end;
- end;
- LECKKLAMMER : begin
- consume(LECKKLAMMER);
- new(constset);
- for l:=0 to 31 do
- constset^[l]:=0;
- p2:=nil;
- pd:=nil;
- if token<>RECKKLAMMER then
- while true do
- begin
- p1:=expr;
- do_firstpass(p1);
- case p1^.treetype of
- ordconstn : begin
- if pd=nil then
- pd:=p1^.resulttype;
- if not(is_equal(pd,p1^.resulttype)) then
- Message(parser_e_typeconflict_in_set)
- else
- do_set(constset,p1^.value);
- disposetree(p1);
- end;
- rangen : begin
- if pd=nil then
- pd:=p1^.left^.resulttype;
- if not(is_equal(pd,p1^.left^.resulttype)) then
- Message(parser_e_typeconflict_in_set)
- else
- for l:=p1^.left^.value to p1^.right^.value do
- do_set(constset,l);
- disposetree(p1);
- end;
- stringconstn : begin
- if pd=nil then
- pd:=cchardef;
- if not(is_equal(pd,cchardef)) then
- Message(parser_e_typeconflict_in_set)
- else
- for l:=1 to length(pstring(p1^.values)^) do
- do_set(constset,ord(pstring(p1^.values)^[l]));
- disposetree(p1);
- end;
- else
- begin
- if pd=nil then
- pd:=p1^.resulttype;
- if not(is_equal(pd,p1^.resulttype)) then
- Message(parser_e_typeconflict_in_set);
- p2:=gennode(setelen,p1,p2);
- end;
- end;
- if token=COMMA then
- consume(COMMA)
- else break;
- end;
- consume(RECKKLAMMER);
- p1:=gensinglenode(setconstrn,p2);
- p1^.resulttype:=new(psetdef,init(pd,255));
- p1^.constset:=constset;
- end;
- PLUS : begin
- consume(PLUS);
- p1:=factor(false);
- end;
- MINUS : begin
- consume(MINUS);
- p1:=factor(false);
- p1:=gensinglenode(umminusn,p1);
- end;
- _NOT : begin
- consume(_NOT);
- p1:=factor(false);
- p1:=gensinglenode(notn,p1);
- end;
- _TRUE : begin
- consume(_TRUE);
- p1:=genordinalconstnode(1,booldef);
- end;
- _FALSE : begin
- consume(_FALSE);
- p1:=genordinalconstnode(0,booldef);
- end;
- _NIL : begin
- consume(_NIL);
- p1:=genzeronode(niln);
- end;
- else
- begin
- p1:=genzeronode(errorn);
- consume(token);
- Message(cg_e_illegal_expression);
- end;
- end;
- factor:=p1;
- end;
-
- type Toperator_precedence=(opcompare,opaddition,opmultiply);
-
- const tok2node:array[PLUS.._XOR] of Ttreetyp=
- (addn,subn,muln,slashn,equaln,gtn,ltn,gten,lten,
- isn,asn,inn,
- nothingn,caretn,nothingn,unequaln,nothingn,
- nothingn,nothingn,nothingn,nothingn,nothingn,
- nothingn,nothingn,nothingn,nothingn,nothingn,
- nothingn,nothingn,nothingn,nothingn,nothingn,
- nothingn,andn,nothingn,nothingn,nothingn,
- nothingn,nothingn,nothingn,nothingn,nothingn,
- nothingn,nothingn,divn,nothingn,nothingn,
- nothingn,nothingn,nothingn,nothingn,nothingn,
- nothingn,nothingn,nothingn,nothingn,nothingn,
- nothingn,nothingn,nothingn,nothingn,nothingn,
- modn,nothingn,nothingn,nothingn,nothingn,
- nothingn,nothingn,orn,
- nothingn,nothingn,nothingn,nothingn,nothingn,
- nothingn,nothingn,shln,shrn,
- nothingn,nothingn,nothingn,nothingn,nothingn,
- nothingn,nothingn,nothingn,nothingn,nothingn,
- nothingn,xorn);
- operator_levels:array[Toperator_precedence] of set of Ttoken=
- ([LT,LTE,GT,GTE,EQUAL,UNEQUAL,_IN,_IS],
- [PLUS,MINUS,_OR,_XOR],
- [CARET,SYMDIF,STAR,SLASH,_DIV,_MOD,_AND,_SHL,_SHR,_AS]);
-
- function sub_expr(pred_level:Toperator_precedence):Ptree;
-
- {Reads a subexpression while the operators are of the current precedence
- level, or any higher level. Replaces the old term, simpl_expr and
- simpl2_expr.}
-
- var p1,p2:Ptree;
- oldt:Ttoken;
-
- begin
- { if pred_level=high(Toperator_precedence) then }
- if pred_level=opmultiply then
- p1:=factor(getprocvar)
- else
- p1:=sub_expr(succ(pred_level));
- repeat
- if token in operator_levels[pred_level] then
- begin
- oldt:=token;
- consume(token);
- { if pred_level=high(Toperator_precedence) then }
- if pred_level=opmultiply then
- p2:=factor(getprocvar)
- else
- p2:=sub_expr(succ(pred_level));
- p1:=gennode(tok2node[oldt],p1,p2);
- end
- else
- break;
- until false;
- sub_expr:=p1;
- end;
-
- function expr : ptree;
-
- var
- p1,p2 : ptree;
- oldafterassignment : boolean;
-
- begin
- oldafterassignment:=afterassignment;
- p1:=sub_expr(opcompare);
- if token in [ASSIGNMENT,_PLUSASN,_MINUSASN,_STARASN,_SLASHASN] then
- afterassignment:=true;
- case token of
- POINTPOINT : begin
- consume(POINTPOINT);
- p2:=sub_expr(opcompare);
- p1:=gennode(rangen,p1,p2);
- end;
- ASSIGNMENT : begin
- consume(ASSIGNMENT);
- { avoid a firstpass of a procedure if
- it must be assigned to a procvar }
- { should be recursive for a:=b:=c !!! }
- if (p1^.resulttype<>nil) and (p1^.resulttype^.deftype=procvardef) then
- getprocvar:=true;
- p2:=sub_expr(opcompare);
- if getprocvar and (p2^.treetype=calln) then
- begin
- p2^.treetype:=loadn;
- p2^.resulttype:=pprocsym(p2^.symtableprocentry)^.definition;
- p2^.symtableentry:=p2^.symtableprocentry;
- end;
- getprocvar:=false;
- p1:=gennode(assignn,p1,p2);
- end;
- { this is the code for C like assignements }
- { from an improvement of Peter Schaefer }
- _PLUSASN : begin
- consume(_PLUSASN );
- p2:=sub_expr(opcompare);
- p1:=gennode(assignn,p1,gennode(addn,getcopy(p1),p2));
- { was first
- p1:=gennode(assignn,p1,gennode(addn,p1,p2));
- but disposetree assumes that we have a real
- *** tree *** }
- end;
-
- _MINUSASN : begin
- consume(_MINUSASN );
- p2:=sub_expr(opcompare);
- p1:=gennode(assignn,p1,gennode(subn,getcopy(p1),p2));
- end;
- _STARASN : begin
- consume(_STARASN );
- p2:=sub_expr(opcompare);
- p1:=gennode(assignn,p1,gennode(muln,getcopy(p1),p2));
- end;
- _SLASHASN : begin
- consume(_SLASHASN );
- p2:=sub_expr(opcompare);
- p1:=gennode(assignn,p1,gennode(slashn,getcopy(p1),p2));
- end;
- end;
- afterassignment:=oldafterassignment;
- expr:=p1;
- end;
-
- function get_intconst:longint;
-
- {Reads an expression, tries to evalute it and check if it is an integer
- constant. Then the constant is returned.}
-
- var p:Ptree;
-
- begin
- p:=expr;
- do_firstpass(p);
- if (p^.treetype<>ordconstn) and
- (p^.resulttype^.deftype=orddef) and
- not (Porddef(p^.resulttype)^.typ in
- [uvoid,uchar,bool8bit]) then
- Message(cg_e_illegal_expression)
- else
- get_intconst:=p^.value;
- disposetree(p);
- end;
-
- function get_stringconst:string;
-
- {Reads an expression, tries to evaluate it and checks if it is a string
- constant. Then the constant is returned.}
-
- var p:Ptree;
-
- begin
- get_stringconst:='';
- p:=expr;
- do_firstpass(p);
- if p^.treetype<>stringconstn then
- if (p^.treetype=ordconstn) and
- (p^.resulttype^.deftype=orddef) and
- (Porddef(p^.resulttype)^.typ=uchar) then
- get_stringconst:=char(p^.value)
- else
- Message(cg_e_illegal_expression)
- else
- get_stringconst:=p^.values^;
- disposetree(p);
- end;
-
- end.
- {
- $Log: pexpr.pas,v $
- Revision 1.2.2.1 1998/05/21 12:26:55 carl
- * crash bugfix
-
- Revision 1.2 1998/03/26 11:18:31 florian
- - switch -Sa removed
- - support of a:=b:=0 removed
-
- Revision 1.1.1.1 1998/03/25 11:18:14 root
- * Restored version
-
- Revision 1.26 1998/03/24 21:48:33 florian
- * just a couple of fixes applied:
- - problem with fixed16 solved
- - internalerror 10005 problem fixed
- - patch for assembler reading
- - small optimizer fix
- - mem is now supported
-
- Revision 1.25 1998/03/21 23:59:39 florian
- * indexed properties fixed
- * ppu i/o of properties fixed
- * field can be also used for write access
- * overriding of properties
-
- Revision 1.24 1998/03/16 22:42:21 florian
- * some fixes of Peter applied:
- ofs problem, profiler support
-
- Revision 1.23 1998/03/11 11:23:57 florian
- * bug0081 and bug0109 fixed
-
- Revision 1.22 1998/03/10 16:27:42 pierre
- * better line info in stabs debug
- * symtabletype and lexlevel separated into two fields of tsymtable
- + ifdef MAKELIB for direct library output, not complete
- + ifdef CHAINPROCSYMS for overloaded seach across units, not fully
- working
- + ifdef TESTFUNCRET for setting func result in underfunction, not
- working
-
- Revision 1.21 1998/03/10 01:17:24 peter
- * all files have the same header
- * messages are fully implemented, EXTDEBUG uses Comment()
- + AG... files for the Assembler generation
-
- Revision 1.20 1998/03/06 00:52:44 peter
- * replaced all old messages from errore.msg, only ExtDebug and some
- Comment() calls are left
- * fixed options.pas
-
- Revision 1.19 1998/03/02 01:49:02 peter
- * renamed target_DOS to target_GO32V1
- + new verbose system, merged old errors and verbose units into one new
- verbose.pas, so errors.pas is obsolete
-
- Revision 1.18 1998/03/01 22:46:18 florian
- + some win95 linking stuff
- * a couple of bugs fixed:
- bug0055,bug0058,bug0059,bug0064,bug0072,bug0093,bug0095,bug0098
-
- Revision 1.17 1998/02/27 21:24:06 florian
- * dll support changed (dll name can be also a string contants)
-
- Revision 1.16 1998/02/24 00:19:17 peter
- * makefile works again (btw. linux does like any char after a \ )
- * removed circular unit with assemble and files
- * fixed a sigsegv in pexpr
- * pmodule init unit/program is the almost the same, merged them
-
- Revision 1.15 1998/02/13 10:35:24 daniel
- * Made Motorola version compilable.
- * Fixed optimizer
-
- Revision 1.14 1998/02/12 17:19:20 florian
- * fixed to get remake3 work, but needs additional fixes (output, I don't like
- also that aktswitches isn't a pointer)
-
- Revision 1.13 1998/02/12 11:50:26 daniel
- Yes! Finally! After three retries, my patch!
-
- Changes:
-
- Complete rewrite of psub.pas.
- Added support for DLL's.
- Compiler requires less memory.
- Platform units for each platform.
-
- Revision 1.12 1998/02/11 21:56:37 florian
- * bugfixes: bug0093, bug0053, bug0088, bug0087, bug0089
-
- Revision 1.11 1998/02/01 22:41:11 florian
- * clean up
- + system.assigned([class])
- + system.assigned([class of xxxx])
- * first fixes of as and is-operator
-
- Revision 1.10 1998/02/01 15:04:15 florian
- * better error recovering
- * some clean up
-
- Revision 1.9 1998/01/30 21:27:05 carl
- * partial bugfix #88, #89 and typeof and other inline functions
- (these bugs have a deeper nesting level, and therefore i only fixed
- the parser crashes - there is also a tree crash).
-
- Revision 1.8 1998/01/26 17:31:01 florian
- * stupid bug with self in class methods fixed
-
- Revision 1.7 1998/01/25 22:29:02 florian
- * a lot bug fixes on the DOM
-
- Revision 1.6 1998/01/23 10:46:41 florian
- * small problems with FCL object model fixed, objpas?.inc is compilable
-
- Revision 1.5 1998/01/16 22:34:42 michael
- * Changed 'conversation' to 'conversion'. Waayyy too much chatting going on
- in this compiler :)
-
- Revision 1.4 1998/01/16 18:03:15 florian
- * small bug fixes, some stuff of delphi styled constructores added
-
- Revision 1.3 1998/01/13 23:11:14 florian
- + class methods
-
- Revision 1.2 1998/01/09 09:09:59 michael
- + Initial implementation, second try
-
- }
-